home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / pars7.exe / GRAFPACK.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-12  |  15KB  |  578 lines
  1. unit grafpack;
  2. {$F+}
  3. interface
  4.  
  5. uses
  6. {$IFDEF DPMI}
  7.   Dos,Crt,Graph, WinAPI,Realtype;
  8. {$ELSE}
  9.   Dos,Crt,Graph,Realtype;
  10. {$ENDIF}
  11. type
  12.    D3World=record
  13.            xw1,xw2,yw1,yw2,zw1,zw2:float;
  14.            end;
  15.  
  16. var
  17.   TheWorld:D3world;
  18.   xwrot,zwrot:integer;
  19.   basex,basey,basez,frontx,fronty,frontz,viewdist:float;
  20.  Graphdriver,Graphmode,XTextglb,YTextglb,VESA16,xw1glb,xw2glb,yw1glb,
  21.  yw2glb:integer;
  22.  charfeedglb,linefeedglb,lineshiftglb:byte;
  23.  Graphmodeglb,VesaGlb:boolean;
  24.  OldOutput : Text;
  25.  xaglb,xscaleglb,yaglb,yscaleglb:float;
  26.  
  27. Procedure InitGraphic(PathToDriver:string);
  28. {Initializes graphics, Redirects the Write and GoToXY-procedures to
  29. work on the graphics screen.}
  30.  
  31. Procedure LeaveGraphic;
  32. {Restores Crt-mode, leaves graphics mode. Use if you want to
  33. switch between the two modes in one program. Before final termination
  34. you also have to use the CloseGraph-command from the Graph-Unit.}
  35.  
  36. Procedure EnterGraphic;
  37. {Switches from Crt-Mode to graphics-mode, InitGraphic must be called
  38. once before.}
  39.  
  40. procedure GotoXY(X, Y : integer);
  41. { Set the text position }
  42.  
  43. procedure setwindow(x1,y1,size:word);
  44. { Defines drawing area; (x1,y1) is upper left point in *text coordinates*,
  45.  size is the *vertical* extension of the window in textlines. The window
  46.  always comes out square. (Roughly)}
  47.  
  48. procedure setd3world(x1,y1,z1,x2,y2,z2,vdist:float;xrot,zrot:integer);
  49. {defines what area of the "real" 3-d-world should be drawn, from what
  50. distance it should be viewed(vdist) and what angles the camera has
  51. with the x and z-axes (xrot,zrot). The 3d-world is always mapped into a
  52. cube with length 2 in each direction that the camera moves around of,
  53. looking into the center of the cube. It has a fixed viewing angle
  54. (it's an older model with a fixed focal distance). The cube is then
  55. projected to the window defined by setwindow. All drawing commands
  56. are then in terms of 3-D-world coordinates.}
  57.  
  58. procedure rotatex(theta:integer);
  59.  
  60. procedure rotatez(theta:integer);
  61.  
  62. procedure zoomin;
  63.  
  64. procedure zoomout;
  65.  
  66. procedure d3drawpoint(x,y,z:float);
  67.  
  68. procedure d3line(xl1,yl1,zl1,xl2,yl2,zl2:float);
  69.  
  70. procedure drawd3axes(c1,c2,c3:string);
  71.  
  72. {self explaining, the rest}
  73. Implementation
  74.  
  75. function XTextpixel(Xtextglb:byte):word;
  76. begin
  77.   XTextpixel:=(XTextglb-1)*Charfeedglb;
  78. end;
  79.  
  80. function YTextpixel(Ytextglb:byte):word;
  81. begin
  82.   YTextpixel:=(YTextglb-1)*linefeedglb+lineshiftglb;
  83. end;
  84.  
  85. var xchar,ychar:word;
  86.  
  87. procedure DC(c:byte);
  88. var viewport:viewporttype; x,y:word;
  89. begin
  90.   getviewsettings(viewport);
  91.   x:=xtextpixel(xtextglb); y:=ytextpixel(ytextglb);
  92.   setviewport(x,y,x+xchar,y+ychar,true);
  93.   clearviewport;
  94.   outtextxy(0,0,chr(c));
  95.   with viewport do setviewport(x1,y1,x2,y2,clip);
  96. end;
  97.  
  98. function WriteGrafChars(var F : TextRec) : integer;
  99. { Used to output graphics characters through the standard output channel. }
  100. const
  101.   BackSpace = #8;
  102.   LineFeed  = #10;
  103.   Return    = #13;
  104. var
  105.   I : integer;
  106. begin
  107.   with F do
  108.     if Mode = fmOutput then
  109.     begin
  110.       if BufPos > BufEnd then
  111.       begin
  112.         for I := BufEnd to Pred(BufPos) do  { Flush the output buffer }
  113.         begin
  114.           case BufPtr^[I] of
  115.             BackSpace : if XTextGlb > 1 then
  116.                           DEC(XTextGlb);
  117.  
  118.             LineFeed  : if YTextGlb < 25 then
  119.                           INC(YTextGlb);
  120.  
  121.             Return    : XTextGlb := 1;
  122.           else
  123.             DC(ORD(BufPtr^[I]));
  124.             if XTextGlb < 80 then
  125.               INC(XTextGlb);
  126.           end; { case }
  127.         end; { for }
  128.       end;
  129.       BufPos := BufEnd;
  130.     end; { if }
  131.   WriteGrafChars := 0;
  132. end; { WriteGrafChars }
  133.  
  134. function GrafCharZero(var F : TextRec) : integer;
  135. { Called when standard output is opened and closed }
  136. begin
  137.   GrafCharZero := 0;
  138. end; { GrafCharZero }
  139.  
  140.  
  141. procedure GrafCharsON;
  142. { Redirects standard output to the WriteGrafChars function. }
  143. begin
  144.   Move(Output, OldOutput, SizeOf(Output));  { Save old output channel }
  145.   with TextRec(Output) do
  146.   begin
  147.     OpenFunc:=@GrafCharZero;       { no open necessary }
  148.     InOutFunc:=@WriteGrafChars;    { WriteGrafChars gets called for I/O }
  149.     FlushFunc:=@WriteGrafChars;    { WriteGrafChars flushes automatically }
  150.     CloseFunc:=@GrafCharZero;      { no close necessary }
  151.     Name[0]:=#0;
  152.   end;
  153. end; { GrafCharsON }
  154.  
  155. procedure GrafCharsOFF;
  156. { Restores original output I/O channel }
  157. begin
  158.   Move(OldOutput, Output, SizeOf(OldOutput));
  159. end; { GrafCharsOFF }
  160.  
  161. procedure GotoXY{(X, Y : integer)};
  162. { Set the text position }
  163. begin
  164.   if (X >= 1) and (X <= 80) and    { Ignore illegal values }
  165.      (Y >= 1) and (Y <= 25) then
  166.   begin
  167.     if GraphModeGlb then
  168.       begin
  169.         XTextGlb := X;      { Set text postion in graphics mode }
  170.         YTextGlb := Y;
  171.       end
  172.     else
  173.       Crt.GotoXY(X, Y);     { Set cursor position in text mode }
  174.   end;
  175. end; { GotoXY }
  176.  
  177.  
  178. type
  179.   VgaInfoBlock = record
  180.     VESASignature: array[0..3] of Byte;
  181.     VESAVersion: Word;
  182.     OEMStringPtr: Pointer;
  183.     Capabilities: array[0..3] of Byte;
  184.     VideoModePtr: Pointer;
  185.   end;
  186.  
  187. const
  188.   VESA16Modes: array[0..2] of Word =
  189.     ($0102, $0104, $0106);
  190.  
  191. { Scan the supported mode table for the highest mode this card
  192.   will provide
  193. }
  194.  
  195. function GetHighestCap(Table: Pointer; Modes: Word; Size: Integer): Integer;
  196.   near; assembler;
  197. asm
  198.         XOR     AX,AX
  199.         LES     DI, Table
  200. @@1:
  201.         MOV     SI, Modes
  202.         ADD     SI, Size
  203.         ADD     SI, Size
  204.         MOV     BX, ES:[DI]
  205.         CMP     BX, 0FFFFH
  206.         JE      @@4
  207.         INC     DI
  208.         INC     DI
  209.         MOV     CX,Size
  210. @@2:
  211.         CMP     BX,[SI]
  212.         JZ      @@3
  213.         DEC     SI
  214.         DEC     SI
  215.         LOOP    @@2
  216. @@3:
  217.         CMP     AX,CX
  218.         JA      @@1
  219.         MOV     AX,CX
  220.         JMP     @@1
  221. @@4:
  222. end;
  223.  
  224. {$IFDEF DPMI}
  225. type
  226.   TRealRegs = record
  227.     RealEDI, RealESI, RealEBP, Reserved, RealEBX,
  228.     RealEDX, RealECX, RealEAX: Longint;
  229.     RealFlags, RealES, RealDS, RealFS, RealGS,
  230.     RealIP, RealCS, RealSP, RealSS: Word;
  231.   end;
  232.  
  233. function DetectVesa16: Integer; far; assembler;
  234. var
  235.   Segment, Selector, VesaCap: Word;
  236. asm
  237. {$IFOPT G+}
  238.         PUSH    0000H
  239.         PUSH    0100H
  240. {$ELSE}
  241.         XOR     AX,AX
  242.         PUSH    AX
  243.         INC     AH
  244.         PUSH    AX
  245. {$ENDIF}
  246.         CALL    GlobalDosAlloc
  247.         MOV     Segment,DX
  248.         MOV     Selector,AX
  249.         MOV     DI,OFFSET RealModeRegs
  250.         MOV     WORD PTR [DI].TRealRegs.RealSP, 0
  251.         MOV     WORD PTR [DI].TRealRegs.RealSS, 0
  252.         MOV     WORD PTR [DI].TRealRegs.RealEAX, 4F00H
  253.         MOV     WORD PTR [DI].TRealRegs.RealES, DX
  254.         MOV     WORD PTR [DI].TRealRegs.RealEDI, 0
  255.         MOV     AX,DS
  256.         MOV     ES,AX
  257.         MOV     AX,0300H
  258.         MOV     BX,0010H
  259.         XOR     CX,CX
  260.         INT     31H
  261.         MOV     DI,OFFSET RealModeRegs
  262.         MOV     AX,grError
  263.         PUSH    AX
  264.         CMP     WORD PTR [DI].TRealRegs.RealEAX,004FH
  265.         JNZ     @@Exit
  266.         POP     AX
  267.         MOV     ES,Selector
  268.         XOR     DI,DI
  269.         CMP     ES:[DI].VgaInfoBlock.VESASignature.Word[0], 'EV'
  270.         JNZ     @@Exit
  271.         CMP     ES:[DI].VgaInfoBlock.VESASignature.Word[2], 'AS'
  272.         JNZ     @@Exit
  273.         MOV     AX,0000
  274.         MOV     CX,1
  275.         INT     31H
  276.         MOV     VesaCap,AX
  277.         MOV     DX,ES:[DI].VgaInfoBlock.VideoModePtr.Word[2]
  278.         MOV     CX,4
  279.         XOR     AX,AX
  280. @@Convert:
  281.         SHL     DX,1
  282.         RCL     AX,1
  283.         LOOP    @@Convert
  284.         ADD     DX,ES:[DI].VgaInfoBlock.VideoModePtr.Word[0]
  285.         ADC     AX,0
  286.         MOV     CX,AX
  287.         MOV     BX,VesaCap
  288.         MOV     AX,0007H
  289.         INT     31H
  290.         INC     AX
  291.         XOR     CX,CX
  292.         MOV     DX,0FFFFH
  293.         INT     31H
  294.         MOV     ES,BX
  295.         PUSH    ES
  296.         PUSH    DI
  297. {$IFOPT G+}
  298.         PUSH    OFFSET Vesa16Modes
  299.         PUSH    0003H
  300. {$ELSE}
  301.         MOV     SI, OFFSET Vesa16Modes
  302.         PUSH    SI
  303.         MOV     AX, 5
  304.         PUSH    AX
  305. {$ENDIF}
  306.         CALL